with Interfaces.C.Pointers;
with Interfaces.C.Strings;

package body FT2.Base is

   package Bitmap_Size_Pointers is new Interfaces.C.Pointers
     (Natural, FT_Bitmap_Size, FT_Bitmap_Size_Array, (0, 0, Zero, Zero, Zero));

   package CharMap_Pointers is new Interfaces.C.Pointers
     (Natural, FT_CharMap, FT_CharMap_Array, null);

   type FT_UInt32s_Ptr is access all FT_UInt32;

   package UInt32_Pointers is new Interfaces.C.Pointers
     (Natural, FT_UInt32, FT_UInt32_Array, 0);

   --------------
   -- To_Array --
   --------------

   function To_Array
     (Ptr : FT_Bitmap_Sizes_Ptr;
      Length : FT_Int)
      return FT_Bitmap_Size_Array
   is
   begin
      return Bitmap_Size_Pointers.Value
        (Bitmap_Size_Pointers.Pointer (Ptr), Interfaces.C.ptrdiff_t (Length));
   end To_Array;

   --------------
   -- To_Array --
   --------------

   function To_Array
     (Ptr : FT_Charmaps_Ptr;
      Length : FT_Int)
      return FT_CharMap_Array
   is
   begin
      return CharMap_Pointers.Value
        (CharMap_Pointers.Pointer (Ptr), Interfaces.C.ptrdiff_t (Length));
   end To_Array;

   ------------------
   -- Get_Charmaps --
   ------------------

   function Get_Charmaps (Face : FT_Face) return FT_CharMap_Array is
   begin
      return To_Array (Face.Charmaps, Face.Num_Charmaps);
   end Get_Charmaps;

   -------------------
   -- Init_FreeType --
   -------------------

   procedure Init_FreeType
     (Library : in out FT_Library;
      Error : out FT_Error)
   is
      function Internal (Library : System.Address) return FT_Error;
      pragma Import (C, Internal, "FT_Init_FreeType");
   begin
      Error := Internal (Library'Address);
   end Init_FreeType;

   -------------------
   -- Done_FreeType --
   -------------------

   procedure Done_FreeType
     (Library : in out FT_Library;
      Error : out FT_Error)
   is
      function Internal (Library : in FT_Library) return FT_Error;
      pragma Import (C, Internal, "FT_Done_FreeType");
   begin
      Error := Internal (Library);
      if Error /= 0 then
         Library := null;
      end if;
   end Done_FreeType;

   --------------
   -- New_Face --
   --------------

   procedure New_Face
     (Library : FT_Library;
      File_Path_Name : String;
      Face_Index : FT_Long;
      Face : in out FT_Face;
      Error : out FT_Error)
   is
      function Internal
        (Library        : FT_Library;
         File_Path_Name : System.Address;
         Face_Index     : FT_Long;
         Face           : System.Address)
        return FT_Error;
      pragma Import (C, Internal, "FT_New_Face");
      C_File_Path_Name : String := File_Path_Name & ASCII.NUL;
   begin
      Error := Internal (Library,
                         C_File_Path_Name'Address,
                         Face_Index,
                         Face'Address);
   end New_Face;

   ---------------------
   -- New_Memory_Face --
   ---------------------

   procedure New_Memory_Face
     (Library : FT_Library;
      File_Base : System.Address;
      File_Size : FT_Long;
      Face_Index : FT_Long;
      Face : in out FT_Face;
      Error : out FT_Error)
   is
      function Internal
        (Library    : FT_Library;
         File_Base  : System.Address;
         File_Size  : FT_Long;
         Face_Index : FT_Long;
         Face       : System.Address)
        return FT_Error;
      pragma Import (C, Internal, "FT_New_Memory_Face");
   begin
      Error := Internal (Library,
                         File_Base,
                         File_Size,
                         Face_Index,
                         Face'Address);
   end New_Memory_Face;

   -----------------
   -- Attach_File --
   -----------------

   procedure Attach_File
     (Face : FT_Face;
      File_Path_Name : String;
      Error : out FT_Error)
   is
      function Internal
        (Face          : FT_Face;
         File_Pathname : System.Address)
        return FT_Error;
      pragma Import (C, Internal, "FT_Attach_File");
      C_File_Path_Name : constant String := File_Path_Name & ASCII.NUL;
   begin
      Error := Internal (Face, C_File_Path_Name'Address);
   end Attach_File;

   ---------------
   -- Done_Face --
   ---------------

   procedure Done_Face
     (Face : in out FT_Face;
      Error : out FT_Error)
   is
      function Internal (Face : FT_Face) return FT_Error;
      pragma Import (C, Internal, "FT_Done_Face");
   begin
      Error := Internal (Face);
      if Error /= 0 then
         Face := null;
      end if;
   end Done_Face;

   -----------------
   -- Select_Size --
   -----------------

   procedure Select_Size
     (Face : FT_Face;
      Strike_Index : FT_Int;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Strike_Index : FT_Int)
         return FT_Error;
      pragma Import (C, Internal, "FT_Select_Size");
   begin
      Error := Internal (Face, Strike_Index);
   end Select_Size;

   ------------------
   -- Request_Size --
   ------------------

   procedure Request_Size
     (Face : FT_Face;
      Req : out FT_Size_RequestRec;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Req : System.Address)
         return FT_Error;
      pragma Import (C, Internal, "FT_Request_Size");
   begin
      Error := Internal (Face, Req'Address);
   end Request_Size;

   -------------------
   -- Set_Char_Size --
   -------------------

   procedure Set_Char_Size
     (Face : FT_Face;
      Char_Width : FT_F26Dot6;
      Char_Height :  FT_F26Dot6;
      Horz_Resolution : FT_UInt;
      Vert_Resolution : FT_UInt;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Char_Width : FT_F26Dot6;
         Char_Height :  FT_F26Dot6;
         Horz_Resolution : FT_UInt;
         Vert_Resolution : FT_UInt)
         return FT_Error;
      pragma Import (C, Internal, "FT_Set_Char_Size");
   begin
      Error := Internal (Face,
                         Char_Width,
                         Char_Height,
                         Horz_Resolution,
                         Vert_Resolution);
   end Set_Char_Size;

   ---------------------
   -- Set_Pixel_Sizes --
   ---------------------

   procedure Set_Pixel_Sizes
     (Face : FT_Face;
      Pixel_Width : FT_UInt;
      Pixel_Height : FT_UInt;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Pixel_Width : FT_UInt;
         Pixel_Height : FT_UInt)
         return FT_Error;
      pragma Import (C, Internal, "FT_Set_Pixel_Sizes");
   begin
      Error := Internal (Face, Pixel_Width, Pixel_Height);
   end Set_Pixel_Sizes;

   ----------------
   -- Load_Glyph --
   ----------------

   procedure Load_Glyph
     (Face : FT_Face;
      Glyph_Index : FT_UInt;
      Load_Flags : FT_Load_Flags;
      Error : out FT_Error)
   is
      function Internal
     (Face : FT_Face;
      Glyph_Index : FT_UInt;
      Load_Flags : FT_Load_Flags)
      return FT_Error;
      pragma Import (C, Internal, "FT_Load_Glyph");
   begin
      Error := Internal (Face, Glyph_Index, Load_Flags);
   end Load_Glyph;

   ---------------
   -- Load_Char --
   ---------------

   procedure Load_Char
     (Face : FT_Face;
      Char_Code : FT_ULong;
      Load_Flags : FT_Load_Flags;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Char_Code : FT_ULong;
         Load_Flags : FT_Load_Flags)
        return FT_Error;
      pragma Import (C, Internal, "FT_Load_Char");
   begin
      Error := Internal (Face, Char_Code, Load_Flags);
   end Load_Char;

   -------------------
   -- Set_Transform --
   -------------------

   procedure Set_Transform
     (Face : FT_Face;
      Matrix : FT_Matrix;
      Vector : FT_Vector)
   is
      procedure Internal
        (Face : FT_Face;
         Matrix : FT_Matrix;
         Vector : FT_Vector);
      pragma Import (C, Internal, "FT_Set_Transform");
   begin
      Internal (Face, Matrix, Vector);
   end Set_Transform;

   -------------------
   -- Set_Transform --
   -------------------

   procedure Set_Transform
     (Face : FT_Face;
      Matrix : FT_Matrix)
   is
      procedure Internal
        (Face : FT_Face;
         Matrix : FT_Matrix;
         Vector : System.Address);
      pragma Import (C, Internal, "FT_Set_Transform");
   begin
      Internal (Face, Matrix, System.Null_Address);
   end Set_Transform;

   -------------------
   -- Set_Transform --
   -------------------

   procedure Set_Transform
     (Face : FT_Face;
      Vector : FT_Vector)
   is
      procedure Internal
        (Face : FT_Face;
         Matrix : System.Address;
         Vector : FT_Vector);
      pragma Import (C, Internal, "FT_Set_Transform");
   begin
      Internal (Face, System.Null_Address, Vector);
   end Set_Transform;

   ------------------
   -- Render_Glyph --
   ------------------

   procedure Render_Glyph
     (Slot : FT_GlyphSlot;
      Render_Mode : FT_Render_Mode;
      Error : out FT_Error)
   is
      function Internal
        (Slot : FT_GlyphSlot;
         Render_mode : FT_Render_Mode)
         return FT_Error;
      pragma Import (C, Internal, "FT_Render_Glyph");
   begin
      Error := Internal (Slot, Render_Mode);
   end Render_Glyph;

   -----------------
   -- Get_Kerning --
   -----------------

   procedure Get_Kerning
     (Face : FT_Face;
      Left_Glyph : FT_UInt;
      Right_Glyph : FT_UInt;
      Kerning_Mode : FT_Kerning_Mode;
      Kerning : out FT_Vector;
      Error : out FT_Error)
   is
      function Internal
        (Face         : FT_Face;
         Left_Glyph   : FT_UInt;
         Right_Glyph  : FT_UInt;
         Kerning_Mode : FT_Kerning_Mode;
         Kerning      : System.Address)
        return FT_Error;
      pragma Import (C, Internal, "FT_Get_Kerning");
   begin
      Error := Internal (Face,
                         Left_Glyph,
                         Right_Glyph,
                         Kerning_Mode,
                         Kerning'Address);
   end Get_Kerning;

   -----------------------
   -- Get_Track_Kerning --
   -----------------------

   procedure Get_Track_Kerning
     (Face : FT_Face;
      Point_Size : FT_Fixed;
      Degree : FT_Int;
      Kerning : out FT_Fixed;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Point_Size : FT_Fixed;
         Degree : FT_Int;
         Kerning : System.Address)
         return FT_Error;
      pragma Import (C, Internal, "FT_Get_Track_Kerning");
   begin
      Error := Internal (Face, Point_Size, Degree, Kerning'Address);
   end Get_Track_Kerning;

   --------------------
   -- Get_Glyph_Name --
   --------------------

   procedure Get_Glyph_Name
     (Face : FT_Face;
      Glyph_Index : FT_UInt;
      Name : out String;
      Last : out Natural;
      Error : out FT_Error)
   is
      function Internal
        (Face        : FT_Face;
         Glyph_Index : FT_UInt;
         Buffer      : System.Address;
         Buffer_Max  : FT_UInt)
         return FT_Error;
      pragma Import (C, Internal, "FT_Get_Glyph_Name");
      Buffer : aliased String (Name'First .. Name'Last + 1);
   begin
      Name := (others => ' ');
      Last := Name'First - 1;
      Error := Internal (Face, Glyph_Index, Buffer'Address, Buffer'Length);
      for I in Buffer'Range loop
         if Buffer (I) /= ASCII.NUL then
            Name (I) := Buffer (I);
            Last := I;
         else
            return;
         end if;
      end loop;
   end Get_Glyph_Name;

   -------------------------
   -- Get_Postscript_Name --
   -------------------------

   function Get_Postscript_Name (Face : FT_Face) return String is
      function Internal
        (Face : FT_Face)
         return Interfaces.C.Strings.chars_ptr;
      pragma Import (C, Internal, "FT_Get_Postscript_Name");
   begin
      return Interfaces.C.Strings.Value (Internal (Face));
   end Get_Postscript_Name;

   --------------------
   -- Select_Charmap --
   --------------------

   procedure Select_Charmap
     (Face : FT_Face;
      Encoding : FT_Encoding;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Encoding : FT_Encoding)
         return FT_Error;
      pragma Import (C, Internal, "FT_Select_Charmap");
   begin
      Error := Internal (Face, Encoding);
   end Select_Charmap;

   -----------------
   -- Set_Charmap --
   -----------------

   procedure Set_Charmap
     (Face : FT_Face;
      Charmap : FT_CharMap;
      Error : out FT_Error)
   is
      function Internal
        (Face : FT_Face;
         Charmap : FT_CharMap)
      return FT_Error;
      pragma Import (C, Internal, "FT_Set_Charmap");
   begin
      Error := Internal (Face, Charmap);
   end Set_Charmap;

   -----------------------
   -- Get_Charmap_Index --
   -----------------------

--     function Get_Charmap_Index (Charmap : FT_CharMap) return FT_Int is
--     begin
--        --  Generated stub: replace with real body!
--        raise Program_Error;
--        return Get_Charmap_Index (Charmap);
--     end Get_Charmap_Index;

   --------------------
   -- Get_Char_Index --
   --------------------

--     function Get_Char_Index
--       (Face : FT_Face;
--        Char_Code : FT_ULong)
--        return FT_UInt
--     is
--     begin
--        --  Generated stub: replace with real body!
--        raise Program_Error;
--        return Get_Char_Index (Face, Char_Code);
--     end Get_Char_Index;

   --------------------
   -- Get_First_Char --
   --------------------

   procedure Get_First_Char
     (Face : FT_Face;
      First_Glyph_Index : out FT_UInt;
      First_Char_Code : out  FT_ULong)
   is
      function Internal
        (Face : FT_Face;
         Glyph_Index : System.Address)
        return FT_ULong;
      pragma Import (C, Internal, "FT_Get_First_Char");
   begin
      First_Char_Code := Internal (Face, First_Glyph_Index'Address);
   end Get_First_Char;

   -------------------
   -- Get_Next_Char --
   -------------------

   procedure Get_Next_Char
     (Face : FT_Face;
      Starting_Char_Code : FT_ULong;
      Next_Glyph_Index : out FT_UInt;
      Next_Char_Code : out FT_ULong)
   is
      function Internal
        (Face : FT_Face;
         Char_Code : FT_ULong;
         Glyph_Index : System.Address)
        return FT_ULong;
      pragma Import (C, Internal, "FT_Get_Next_Char");
   begin
      Next_Char_Code := Internal (Face,
                                  Starting_Char_Code,
                                  Next_Glyph_Index'Address);
   end Get_Next_Char;

   --------------------
   -- Get_Name_Index --
   --------------------

   function Get_Name_Index
     (Face : FT_Face;
      Glyph_Name : String)
      return FT_UInt
   is
      function Internal
        (Face       : FT_Face;
         Glyph_Name : System.Address)
        return FT_UInt;
      pragma Import (C, Internal, "FT_Get_Name_Index");
      C_Glyph_Name : String := Glyph_Name & ASCII.NUL;
   begin
      return Internal (Face, C_Glyph_Name'Address);
   end Get_Name_Index;

   -----------------------
   -- Get_SubGlyph_Info --
   -----------------------

   procedure Get_SubGlyph_Info
     (Glyph : FT_GlyphSlot;
      Sub_Index : FT_UInt;
      Index : out FT_Int;
      Flags : out FT_SubGlyph_Flags;
      Arg1 : out FT_Int;
      Arg2 : out FT_Int;
      Transform : out FT_Matrix;
      Error : out FT_Error)
   is
      function Internal
        (Glyph : FT_GlyphSlot;
         Sub_Index : FT_UInt;
         Index : System.Address;
         Flags : System.Address;
         Arg1 : System.Address;
         Arg2 : System.Address;
         Transform : System.Address)
         return FT_Error;
      pragma Import (C, Internal, "FT_Get_SubGlyph_Info");
   begin
      Error := Internal (Glyph,
                         Sub_Index,
                         Index'Address,
                         Flags'Address,
                         Arg1'Address,
                         Arg2'Address,
                         Transform'Address);
   end Get_SubGlyph_Info;

   ----------------------
   -- Get_FSType_Flags --
   ----------------------

--     function Get_FSType_Flags (Face : FT_Face) return FT_FSType_Flags is
--     begin
--        --  Generated stub: replace with real body!
--        raise Program_Error;
--        return Get_FSType_Flags (Face);
--     end Get_FSType_Flags;

   ----------------------------
   -- Get_Char_Variant_Index --
   ----------------------------

--     function Get_Char_Variant_Index
--       (Face : FT_Face;
--        Char_Code : FT_ULong;
--        Variant_Selector : FT_ULong)
--        return FT_UInt
--     is
--     begin
--        --  Generated stub: replace with real body!
--        raise Program_Error;
--        return Get_Char_Variant_Index (Face, Char_Code, Variant_Selector);
--     end Get_Char_Variant_Index;

   ---------------------------------
   -- Get_Char_Variant_Is_Default --
   ---------------------------------

--     function Get_Char_Variant_Is_Default
--       (Face : FT_Face;
--        Char_Code : FT_ULong;
--        Variant_Selector : FT_ULong)
--        return FT_Int
--     is
--     begin
--        --  Generated stub: replace with real body!
--        raise Program_Error;
--        return Get_Char_Variant_Is_Default (Face, Char_Code, Variant_Selector);
--     end Get_Char_Variant_Is_Default;

   ---------------------------
   -- Get_Variant_Selectors --
   ---------------------------

   function Get_Variant_Selectors
     (Face : FT_Face)
      return FT_UInt32_Array
   is
      function Internal
        (Face : FT_Face)
         return FT_UInt32s_Ptr;
      pragma Import (C, Internal, "FT_Face_GetVariantSelectors");
      Ptr : FT_UInt32s_Ptr;
   begin
      Ptr := Internal (Face);
      if Ptr /= null then
         return UInt32_Pointers.Value (UInt32_Pointers.Pointer (Ptr));
      else
         return FT_UInt32_Array'(0 .. -1 => 0);
      end if;
   end Get_Variant_Selectors;

   --------------------------
   -- Get_Variants_Of_Char --
   --------------------------

   function Get_Variants_Of_Char
     (Face : FT_Face;
      Char_Code : FT_ULong)
      return FT_UInt32_Array
   is
      function Internal
        (Face : FT_Face;
         Char_Code : FT_ULong)
         return FT_UInt32s_Ptr;
      pragma Import (C, Internal, "FT_Face_GetVariantsOfChar");
      Ptr : FT_UInt32s_Ptr;
   begin
      Ptr := Internal (Face, Char_Code);
      if Ptr /= null then
         return UInt32_Pointers.Value (UInt32_Pointers.Pointer (Ptr));
      else
         return FT_UInt32_Array'(0 .. -1 => 0);
      end if;
   end Get_Variants_Of_Char;

   --------------------------
   -- Get_Chars_Of_Variant --
   --------------------------

   function Get_Chars_Of_Variant
     (Face : FT_Face;
      Variant_Selector : FT_ULong)
      return FT_UInt32_Array
   is
      function Internal
        (Face : FT_Face;
         Variant_Selector : FT_ULong)
         return FT_UInt32s_Ptr;
      pragma Import (C, Internal, "FT_Face_GetCharsOfVariant");
      Ptr : FT_UInt32s_Ptr;
   begin
      Ptr := Internal (Face, Variant_Selector);
      if Ptr /= null then
         return UInt32_Pointers.Value (UInt32_Pointers.Pointer (Ptr));
      else
         return FT_UInt32_Array'(0 .. -1 => 0);
      end if;
   end Get_Chars_Of_Variant;

   ----------------------------
   -- Check_TrueType_Patents --
   ----------------------------

   function Check_TrueType_Patents
     (Face : FT_Face)
      return Boolean
   is
      function Internal
        (Face : FT_Face)
         return FT_UChar;
      pragma Import (C, Internal, "FT_Face_CheckTrueTypePatents");
      use Interfaces.C;
   begin
      return Internal (Face) /= 0;
   end Check_TrueType_Patents;

   ----------------------------
   -- Set_Unpatented_Hinting --
   ----------------------------

   procedure Set_Unpatented_Hinting
     (Face : FT_Face;
      Value : Boolean;
      Old_Value : out Boolean)
   is
      function Internal
        (Face : FT_Face;
         Value : FT_UChar)
         return FT_UChar;
      pragma Import (C, Internal, "FT_Face_SetUnpatentedHinting");
      use Interfaces.C;
   begin
      Old_Value := Internal (Face, Boolean'Pos (Value)) /= 0;
   end Set_Unpatented_Hinting;

end FT2.Base;
